;;; Helper functions for reporting errors

(in-package :gwee)

(defclass error-box (text-area)
  ()
  (:default-initargs
   :background (color 255 0 0)
    :border-color (gray 0)
    :foreground (gray 255)))

(defmethod key-press-event ((view error-box) key)
  (when (eq (key-sym key) :sdl-key-space)
    (throw 'quit nil)))    

(defun save-crashlog (condition)
  (multiple-value-bind (sec min h d m y) (decode-universal-time (get-universal-time))
    (let* ((id (format nil "~2,'0d~2,'0d~2,'0d" h min sec))
	   (dir (format nil "crash-~a" id)))
      (ensure-directories-exist (error-pathname dir))
      (with-open-file (s (error-pathname dir "backtrace-~a.txt" id)
			 :direction :output
			 :if-does-not-exist :create
			 :if-exists :append)
	(format s "~&~2,'0d:~2,'0d:~2,'0d ~2,'0d/~2,'0d/~d~%Error: ~a~%" h min sec d m y condition)
	(print-backtrace s))
      ;; take a screenshot for good measure
      #+(or darwin macosx)
      (let ((file (error-pathname dir "screenshot-~a.png" id)))
        (run-program "screencapture" (list "-x" (namestring file)) :wait t)
        ;; For some reason on lispworks screencapture
        ;; finishes executing but doesn't create the file
        ;; right away. So wait for 10 seconds for it to
        ;; appear before going on. Otherwise it seems to take
        ;; a snapshot at the right moment.  Furthermore,
        ;; lispworks' sleep function doesn't seem to do
        ;; anything possibly because multiprocessing hasn't
        ;; been enabled, so spin in a busy-wait loop.
        (loop with start = (get-internal-real-time)
              until (or (probe-file file)
                        (> (- (get-internal-real-time) start) (* 10 internal-time-units-per-second)))))
      #+(or darwin macosx)
      (run-program "/bin/sh" (list "-c" (format nil "cd ~a && tar zcf crash-~a.tgz crash-~a && rm -r crash-~a" (error-pathname ".") id id id)) :wait t))))

(defun save-error-and-quit (condition &optional hook-value)
  (declare (ignore hook-value))
  (save-crashlog condition)
  ;; let the user know in a friendly way
  (let* ((w 350) (h 100)
	 (x (truncate (- (view-width *top-view*) w) 2))
	 (y (truncate (- (view-height *top-view*) h) 2))
	 (view (make-instance 'error-box
			      :data '("Oh no! I've crashed." "Press SPACE to close this program.")
			      :horizontal-justification :center
			      :vertical-justification :center
			      :x x :y y
			      :width w :height h
			      :parent *top-view*)))
    ;; Don't let any other views draw themselves.
    (setf (views-needing-update *top-view*) nil
          *timer-list* nil
          *idle-queue* nil
          (view-cache-top-x view) (translate-x-to-top 0 view)
          (view-cache-top-y view) (translate-y-to-top 0 view))
    (grab-keyboard view)
    (grab-mouse view)
    (draw-view view)
    (update-display)
    (dispatch-events :update-views nil)))

(defvar *crash-handler* nil ;;'save-error-and-quit
  "What function to call when an unhandled error pops up.")

(defun crash-handler-helper (c)
  (if *crash-handler*
      (funcall *crash-handler* c)
      (error c)))
